home *** CD-ROM | disk | FTP | other *** search
/ SGI Freeware 1999 August / SGI Freeware 1999 August.iso / dist / fw_emacs.idb / usr / freeware / share / emacs / 19.34 / lisp / life.el.z / life.el
Encoding:
Text File  |  1998-10-28  |  9.8 KB  |  284 lines
  1. ;;; life.el --- John Horton Conway's `Life' game for GNU Emacs
  2.  
  3. ;; Copyright (C) 1988 Free Software Foundation, Inc.
  4.  
  5. ;; Author: Kyle Jones <talos!kjones@uunet.uu.net>
  6. ;; Keywords: games
  7.  
  8. ;; This file is part of GNU Emacs.
  9.  
  10. ;; GNU Emacs is free software; you can redistribute it and/or modify
  11. ;; it under the terms of the GNU General Public License as published by
  12. ;; the Free Software Foundation; either version 2, or (at your option)
  13. ;; any later version.
  14.  
  15. ;; GNU Emacs is distributed in the hope that it will be useful,
  16. ;; but WITHOUT ANY WARRANTY; without even the implied warranty of
  17. ;; MERCHANTABILITY or FITNESS FOR A PARTICULAR PURPOSE.  See the
  18. ;; GNU General Public License for more details.
  19.  
  20. ;; You should have received a copy of the GNU General Public License
  21. ;; along with GNU Emacs; see the file COPYING.  If not, write to the
  22. ;; Free Software Foundation, Inc., 59 Temple Place - Suite 330,
  23. ;; Boston, MA 02111-1307, USA.
  24.  
  25. ;;; Commentary:
  26.  
  27. ;; A demonstrator for John Horton Conway's "Life" cellular automaton
  28. ;; in Emacs Lisp.  Picks a random one of a set of interesting Life
  29. ;; patterns and evolves it according to the familiar rules.
  30.  
  31. ;;; Code:
  32.  
  33. (defconst life-patterns
  34.   [("@@@" " @@" "@@@")
  35.    ("@@@ @@@" "@@  @@ " "@@@ @@@")
  36.    ("@@@ @@@" "@@   @@" "@@@ @@@")
  37.    ("@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@")
  38.    ("@@@@@@@@@@")
  39.    ("   @@@@@@@@@@       "
  40.     "     @@@@@@@@@@     "
  41.     "       @@@@@@@@@@   "
  42.     "@@@@@@@@@@          "
  43.     "@@@@@@@@@@          ")
  44.    ("@" "@" "@" "@" "@" "@" "@" "@" "@" "@" "@" "@" "@" "@" "@")
  45.    ("@               @" "@               @"  "@               @"
  46.     "@               @" "@               @"  "@               @"
  47.     "@               @" "@               @"  "@               @"
  48.     "@               @" "@               @"  "@               @"
  49.     "@               @" "@               @"  "@               @")
  50.    ("@@               " " @@              " "  @@             "
  51.     "   @@            " "    @@           " "     @@          "
  52.     "      @@         " "       @@        " "        @@       "
  53.     "         @@      " "          @@     " "           @@    "
  54.     "            @@   " "             @@  " "              @@ "
  55.     "               @@")
  56.    ("@@@@@@@@@" "@   @   @" "@ @@@@@ @" "@ @   @ @" "@@@   @@@" 
  57.     "@ @   @ @" "@ @@@@@ @" "@   @   @" "@@@@@@@@@")]
  58.   "Vector of rectangles containing some Life startup patterns.")
  59.  
  60. ;; Macros are used macros for manifest constants instead of variables
  61. ;; because the compiler will convert them to constants, which should
  62. ;; eval faster than symbols.
  63. ;;
  64. ;; Don't change any of the life-* macro constants unless you thoroughly
  65. ;; understand the `life-grim-reaper' function.
  66.  
  67. (defmacro life-life-char () ?@)
  68. (defmacro life-death-char () (1+ (life-life-char)))
  69. (defmacro life-birth-char () 3)
  70. (defmacro life-void-char () ?\ )
  71.  
  72. (defmacro life-life-string () (char-to-string (life-life-char)))
  73. (defmacro life-death-string () (char-to-string (life-death-char)))
  74. (defmacro life-birth-string () (char-to-string (life-birth-char)))
  75. (defmacro life-void-string () (char-to-string (life-void-char)))
  76. (defmacro life-not-void-regexp () (concat "[^" (life-void-string) "\n]"))
  77.  
  78. (defmacro life-increment (variable) (list 'setq variable (list '1+ variable)))
  79.  
  80.  
  81. ;; list of numbers that tell how many characters to move to get to
  82. ;; each of a cell's eight neighbors.
  83. (defconst life-neighbor-deltas nil)
  84.  
  85. ;; window display always starts here.  Easier to deal with than
  86. ;; (scroll-up) and (scroll-down) when trying to center the display.
  87. (defconst life-window-start nil)
  88.  
  89. ;; For mode line
  90. (defconst life-current-generation nil)
  91. ;; Sadly, mode-line-format won't display numbers.
  92. (defconst life-generation-string nil)
  93.  
  94. (defvar life-initialized nil
  95.   "Non-nil if `life' has been run at least once.")
  96.  
  97. ;;;###autoload
  98. (defun life (&optional sleeptime)
  99.   "Run Conway's Life simulation.
  100. The starting pattern is randomly selected.  Prefix arg (optional first
  101. arg non-nil from a program) is the number of seconds to sleep between
  102. generations (this defaults to 1)."
  103.   (interactive "p")
  104.   (or life-initialized
  105.       (random t))
  106.   (setq life-initialized t)
  107.   (or sleeptime (setq sleeptime 1))
  108.   (life-setup)
  109.   (life-display-generation sleeptime)
  110.   (catch 'life-exit
  111.     (while t
  112.       (let ((inhibit-quit t))
  113.     (life-grim-reaper)
  114.     (life-expand-plane-if-needed)
  115.     (life-increment-generation)
  116.     (life-display-generation sleeptime)))))
  117.  
  118. (defalias 'life-mode 'life)
  119. (put 'life-mode 'mode-class 'special)
  120.  
  121. (defun life-setup ()
  122.   (let (n)
  123.     (switch-to-buffer (get-buffer-create "*Life*") t)
  124.     (erase-buffer)
  125.     (kill-all-local-variables)
  126.     (setq case-fold-search nil
  127.       mode-name "Life"
  128.       major-mode 'life-mode
  129.       truncate-lines t
  130.       life-current-generation 0
  131.       life-generation-string "0"
  132.       mode-line-buffer-identification '("Life: generation "
  133.                         life-generation-string)
  134.       fill-column (1- (window-width))
  135.       life-window-start 1)
  136.     (buffer-disable-undo (current-buffer))
  137.     ;; stuff in the random pattern
  138.     (life-insert-random-pattern)
  139.     ;; make sure (life-life-char) is used throughout
  140.     (goto-char (point-min))
  141.     (while (re-search-forward (life-not-void-regexp) nil t)
  142.       (replace-match (life-life-string) t t))
  143.     ;; center the pattern horizontally
  144.     (goto-char (point-min))
  145.     (setq n (/ (- fill-column (save-excursion (end-of-line) (point))) 2))
  146.     (while (not (eobp))
  147.       (indent-to n)
  148.       (forward-line))
  149.     ;; center the pattern vertically
  150.     (setq n (/ (- (1- (window-height))
  151.           (count-lines (point-min) (point-max)))
  152.            2))
  153.     (goto-char (point-min))
  154.     (newline n)
  155.     (goto-char (point-max))
  156.     (newline n)
  157.     ;; pad lines out to fill-column
  158.     (goto-char (point-min))
  159.     (while (not (eobp))
  160.       (end-of-line)
  161.       (indent-to fill-column)
  162.       (move-to-column fill-column)
  163.       (delete-region (point) (progn (end-of-line) (point)))
  164.       (forward-line))
  165.     ;; expand tabs to spaces
  166.     (untabify (point-min) (point-max))
  167.     ;; before starting be sure the automaton has room to grow
  168.     (life-expand-plane-if-needed)
  169.     ;; compute initial neighbor deltas
  170.     (life-compute-neighbor-deltas)))
  171.  
  172. (defun life-compute-neighbor-deltas ()
  173.   (setq life-neighbor-deltas
  174.     (list -1 (- fill-column)
  175.           (- (1+ fill-column)) (- (+ 2 fill-column))
  176.           1 fill-column (1+ fill-column)
  177.           (+ 2 fill-column))))
  178.  
  179. (defun life-insert-random-pattern ()
  180.   (insert-rectangle
  181.    (elt life-patterns (random (length life-patterns))))
  182.   (insert ?\n))
  183.  
  184. (defun life-increment-generation ()
  185.   (life-increment life-current-generation)
  186.   (setq life-generation-string (int-to-string life-current-generation)))
  187.  
  188. (defun life-grim-reaper ()
  189.   ;; Clear the match information.  Later we check to see if it
  190.   ;; is still clear, if so then all the cells have died.
  191.   (store-match-data nil)
  192.   (goto-char (point-min))
  193.   ;; For speed declare all local variable outside the loop.
  194.   (let (point char pivot living-neighbors list)
  195.     (while (search-forward (life-life-string) nil t)
  196.       (setq list life-neighbor-deltas
  197.         living-neighbors 0
  198.         pivot (1- (point)))
  199.       (while list
  200.     (setq point (+ pivot (car list))
  201.           char (char-after point))
  202.     (cond ((eq char (life-void-char))
  203.            (subst-char-in-region point (1+ point)
  204.                      (life-void-char) 1 t))
  205.           ((< char 3)
  206.            (subst-char-in-region point (1+ point) char (1+ char) t))
  207.           ((< char 9)
  208.            (subst-char-in-region point (1+ point) char 9 t))
  209.           ((>= char (life-life-char))
  210.            (life-increment living-neighbors)))
  211.     (setq list (cdr list)))
  212.       (if (memq living-neighbors '(2 3))
  213.       ()
  214.     (subst-char-in-region pivot (1+ pivot)
  215.                 (life-life-char) (life-death-char) t))))
  216.   (if (null (match-beginning 0))
  217.       (life-extinct-quit))
  218.   (subst-char-in-region 1 (point-max) 9 (life-void-char) t)
  219.   (subst-char-in-region 1 (point-max) 1 (life-void-char) t)
  220.   (subst-char-in-region 1 (point-max) 2 (life-void-char) t)
  221.   (subst-char-in-region 1 (point-max) (life-birth-char) (life-life-char) t)
  222.   (subst-char-in-region 1 (point-max) (life-death-char) (life-void-char) t))
  223.  
  224. (defun life-expand-plane-if-needed ()
  225.   (catch 'done
  226.     (goto-char (point-min))
  227.     (while (not (eobp))
  228.       ;; check for life at beginning or end of line.  If found at
  229.       ;; either end, expand at both ends,
  230.       (cond ((or (eq (following-char) (life-life-char))
  231.          (eq (progn (end-of-line) (preceding-char)) (life-life-char)))
  232.          (goto-char (point-min))
  233.          (while (not (eobp))
  234.            (insert (life-void-char))
  235.            (end-of-line)
  236.            (insert (life-void-char))
  237.            (forward-char))
  238.        (setq fill-column (+ 2 fill-column))
  239.        (scroll-left 1)
  240.        (life-compute-neighbor-deltas)
  241.        (throw 'done t)))
  242.       (forward-line)))
  243.   (goto-char (point-min))
  244.   ;; check for life within the first two lines of the buffer.
  245.   ;; If present insert two lifeless lines at the beginning..
  246.   (cond ((search-forward (life-life-string)
  247.              (+ (point) fill-column fill-column 2) t)
  248.      (goto-char (point-min))
  249.      (insert-char (life-void-char) fill-column)
  250.      (insert ?\n)
  251.      (insert-char (life-void-char) fill-column)
  252.      (insert ?\n)
  253.      (setq life-window-start (+ life-window-start fill-column 1))))
  254.   (goto-char (point-max))
  255.   ;; check for life within the last two lines of the buffer.
  256.   ;; If present insert two lifeless lines at the end.
  257.   (cond ((search-backward (life-life-string)
  258.               (- (point) fill-column fill-column 2) t)
  259.      (goto-char (point-max))
  260.      (insert-char (life-void-char) fill-column)
  261.      (insert ?\n)
  262.      (insert-char (life-void-char) fill-column)
  263.      (insert ?\n)
  264.      (setq life-window-start (+ life-window-start fill-column 1)))))
  265.  
  266. (defun life-display-generation (sleeptime)
  267.   (goto-char life-window-start)
  268.   (recenter 0)
  269.   
  270.   ;; Redisplay; if the user has hit a key, exit the loop.
  271.   (or (eq t (sit-for sleeptime))
  272.       (throw 'life-exit nil)))
  273.  
  274. (defun life-extinct-quit ()
  275.   (life-display-generation 0)
  276.   (signal 'life-extinct nil))
  277.  
  278. (put 'life-extinct 'error-conditions '(life-extinct quit))
  279. (put 'life-extinct 'error-message "All life has perished")
  280.  
  281. (provide 'life)
  282.  
  283. ;;; life.el ends here
  284.